module InputParser where

import Data
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(haskellStyle)


parseInput :: String -> String -> Either ParseError [Module]
parseInput = parse inputParser

inputParser :: GenParser Char a [Module]
inputParser =
  do
    whiteSpace
    many comment
    m <- many moduleblock
    many comment
    return m

parseStartpoint :: String -> Either ParseError StartPoint
parseStartpoint = parse startPointParser "Command line"

startPointParser :: GenParser Char a StartPoint
startPointParser =
  do
    mname <- modulename
    char '.'
    nt <- nonterminal
    return (StartPoint nt mname)

comment :: GenParser Char a ()
comment =
  do
    string "/*"
    manyTill anyChar (try (string "*/"))
    whiteSpace

moduleblock :: GenParser Char a Module
moduleblock =
  do
    reserved "module"
    name <- modulename
    reserved "{"
    content <- modulecontent
    reserved "}"
    return (Module name content)

modulename :: GenParser Char a String
modulename = identifier <?> "module name"

modulecontent = many statement

statement :: GenParser Char a Statement
statement =
  do
    s <-
      try abstractStatement
      <|> try importStatement
      <|> try overrideStatement
      <|> rule
    reserved ";"
    return s
  <?> "statement"

abstractStatement :: GenParser Char a Statement
abstractStatement =
  do
    reserved "abstract"
    n <- nonterminal
    return (Abstract n)
  <?> "abstract"

importStatement :: GenParser Char a Statement
importStatement =
  do
    reserved "import"
    mname <- modulename
    iopts <- importOptions []
    return (Import mname iopts)
  <?> "import"

importOptions :: [ImportOption] -> GenParser Char a [ImportOption]
importOptions opts =
  do
    reserved "rename"
    n1 <- nonterminal
    reserved "as"
    n2 <- nonterminal
    importOptions (opts ++ [Rename n1 n2])
  <|>
  do
    reserved "drop"
    n <- nonterminal
    importOptions (opts ++ [Drop n])
  <|>
    return opts

overrideStatement :: GenParser Char a Statement
overrideStatement =
  do
    reserved "override"
    r <- rule
    return (Override r)
  <?> "override"

rule :: GenParser Char a Statement
rule =
  do
    n <- nonterminal
    arrow
    rs <- rightside [] ""
    return (Rule n rs)
  <?> "rule"

{--
FIXME(dum8d0g) :
  attempt to commit a crime against 'good programming style' here
--}
-- rightside :: Parsed rightsides -> Previously parsed thing -> All parsed rs.
rightside :: [[Element]] -> String -> GenParser Char a [[Element]]
rightside xss "" =
  do
    pipe
    rightside (xss ++ [[]]) "pipe"
  <|>
  do
    es <- many1 element
    rightside (xss ++ [es]) "elem"
  <|>
    return (xss ++ [[]])
rightside xss "elem" =
  do
    pipe
    rightside xss "pipe"
  <|>
    return xss
rightside xss "pipe" =
  do
    es <- many1 element
    rightside (xss ++ [es]) "elem"
  <|>
  do
    pipe
    rightside (xss ++ [[]]) "pipe"
  <|>
    return (xss ++ [[]])

element :: GenParser Char a Element
element = terminal <|> nonterminal

pipe :: GenParser Char a ()
pipe = reserved "|" <?> "pipe"

arrow :: GenParser Char a ()
arrow = reserved "=>" <|> reserved "->"

nonterminal :: GenParser Char a Element
nonterminal =
  do
    n <- identifier
    return (Nonterminal n)
  <?> "nonterminal"

terminal :: GenParser Char a Element
terminal =
  do
    char '\''
    t <- manyTill anyChar (try (char '\''))
    whiteSpace
    return (Terminal t)
  <?> "terminal"

--lexer :: TokenParser a
lexer = P.makeTokenParser haskellDef

--haskellDef :: LanguageDef a
haskellDef = haskellStyle
            { P.reservedNames = [ "module", "abstract", "import", "override",
            "rename", "as", "drop", "=>", "->", "|", ";", "{", "}" ],
              P.caseSensitive = True
            }

whiteSpace :: GenParser Char a ()
whiteSpace = P.whiteSpace lexer

identifier :: GenParser Char a String
identifier = P.identifier lexer

reserved :: String -> GenParser Char a ()
reserved   = P.reserved lexer

-- EOF
